home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / comp0_89.lha / Feel / Boot / Compiler / debug.em < prev    next >
Lisp/Scheme  |  1993-02-02  |  2KB  |  79 lines
  1. ;; Eulisp Module
  2. ;; Author: pab
  3. ;; File: debug.em
  4. ;; Date: Sun Jun  7 20:31:35 1992
  5. ;;
  6. ;; Project:
  7. ;; Description: 
  8. ;;
  9.  
  10. (defmodule debug
  11.   (standard0
  12.    list-fns
  13.    
  14.    )
  15.   ()
  16.     
  17.   (defconstant find-debug-form (mk-finder))
  18.   
  19.   (defcondition Debug-Error ())
  20.   
  21.   (defstruct code-info ()
  22.     ((text initarg text 
  23.        reader code-text)
  24.      (pre-break initform nil
  25.         accessor code-pre-break)
  26.      (post-break initform nil 
  27.          accessor code-post-break)
  28.      (id initarg id
  29.      accessor code-id))
  30.     constructor make-code-info)
  31.  
  32.   (defun lookup-break (id)
  33.     (let ((tree (find-debug-form (car id))))
  34.       (if (null tree)
  35.       (error "no such debug" Debug-Error)
  36.     (lookup-form id tree))))
  37.  
  38.   (defun lookup-form (id tree)
  39.     (if (null id) 
  40.     tree
  41.       (let ((nt (assq id tree)))
  42.     (if (null nt)
  43.         (error "couldn't find it")
  44.       ))))
  45.  
  46.   (defun annotate-text (code)
  47.     (let ((name (gensym)))
  48.       (labels ((annotate-list-1 (lst n)
  49.                 (cond ((null lst) nil)
  50.                       (t (let ((xx (annotate-text (car lst))))
  51.                        (cons (list n (car lst) xx)
  52.                          (annotate-list-1 (cdr lst) (+ n 1)))))))
  53.            (annotate-list (lst)
  54.                   (annotate-list-1 lst 0))
  55.            )
  56.           (cond ((atom code) code)
  57.             ((eq (car code) 'quote)
  58.              code)
  59.             ((eq (car code) 'lambda)
  60.              (cons 'lambda 
  61.                (cons (cadr code)
  62.                  (annotate-list (cddr code)))))
  63.             (t (annotate-list code)))))
  64.     
  65. )
  66.      
  67.   (defun macro-namep (sym mod)
  68.     (if (symbolp sym)
  69.     (if (dynamic-accessible-p (get-module mod) sym)
  70.         (let ((xx (dynamic-access (get-module mod) sym)))
  71.           (if (macrop xx) 
  72.           xx
  73.         nil))
  74.       nil)
  75.       nil))
  76.            
  77.   ;; end module
  78.   )
  79.